MacFormat 1995 March/macformat-022.iso/Shareware City/Developers/src/menu-slide-11-p/MenuSlide/MenuSlide.p

Text File | 1994-11-23 | 6.4 KB | 306 lines | [TEXT/PJMM]

program MenuSlide;

{    Original concept and design by [e-mail]                         }
{    Code to find right edge of application menus contributed by                    }
{ Matthew Axsom ([e-mail]) }

{    Written using THINK Pascal 4.0                                                            }

{    Have a look at the accompanying MenuSlide.txt file if you didn't see    }
{    the original posting about what it does and why. "These things            }
{    will become clear to you...at least, clearer than they are at                }
{    the moment" - Slartibartfast in HHG to the G                                        }

{    Feel free to use this code for whatever purpose you like. If you can     }
{    write an INIT/cdev that would work for all applications, please do!     }

const
{    Private event codes that I use    }
    suspendEvent = 12;
    resumeEvent = 13;
    motionEvent = 14;

    MBarHeightAddr = $0BAA;

{    The menus are mostly non-functional, but we need them to demonstrate    }
    kAppleMenu = 128;
    kFileMenu = 129;
    kEditMenu = 130;
    kOtherMenu = 131;

    cQuit = 9;    { File menu - this command really works }

var
    myWindow: WindowPtr;
    myText: Handle;

procedure handleMousePress (event: EventRecord);
forward;

procedure mouseInMenu (event: EventRecord);
forward;

procedure handleWindowUpdate (event: EventRecord);
forward;

procedure handleSuspend (event: EventRecord);
forward;
procedure handleResume (event: EventRecord);
forward;

procedure ExitApp;
forward;

{ Mathew's code, translated from C }

const
    LMMenuListAddr = $0A1C;

type
    MenuRec = record
            mh: MenuHandle;
            startLeft: Integer;
        end;
    MenuRecPtr = ^MenuRec;
    MenuRecHand = ^MenuRecPtr;

    MenuListRec = record
            size: Integer; { div sizeof(MenuRec) for number of items }
            nextLeft: Integer; { Where next edge will go }
            filler: Integer;
            item: array[0..0] of MenuRec; { List of menus }
        end;
    MenuListPtr = ^MenuListRec;
    MenuListHand = ^MenuListPtr;

function MBarRightEdge: Integer;
    var
        p: ^MenuListHand;
        list: MenuListHand;
    begin
    p := pointer(LMMenuListAddr);
    list := p^;
    MBarRightEdge := list^^.nextLeft;
    end;

(****        Sliding the menu bar        ****)

function MBarHeight: Integer;
    var
        p: ^Integer;
    begin
    p := pointer(MBarHeightAddr);
    MBarHeight := p^;
    end;

procedure slideMenuOff;
    var
        savePort, desktop: GrafPtr;
        rightEdge, step: Integer;
        source, dest: Rect;
        saveGray, menuBox: RgnHandle;
        now: LongInt;
    begin
{ Look at low memory menu list to work out where right edge of application menus is }
    rightEdge := MBarRightEdge;
{ Need to fool around with the desktop. This is similar to hiding the menu bar. }
    GetWMgrPort(desktop);
    saveGray := NewRgn;
    CopyRgn(GetGrayRgn, saveGray);
    SetRect(source, 0, 0, screenBits.bounds.right, MBarHeight);
    menuBox := NewRgn;
    RectRgn(menuBox, source);
    UnionRgn(GetGrayRgn, menuBox, GetGrayRgn);
{ OK, now scroll the menu off the screen }
    SetRect(source, 0, 0, rightEdge, MBarHeight);
    dest := source;
    step := 1;
    while (dest.right > 0) do
        begin
        OffsetRect(dest, -step, 0);
        CopyBits(desktop^.portBits, desktop^.portBits, source, dest, srcCopy, nil);
{ Wait a tick }
        now := TickCount;
        while now = TickCount do
            ;
        step := step * 2;
        end;
{ And put things back }
    CopyRgn(saveGray, GetGrayRgn);
    DisposeRgn(saveGray);
    DisposeRgn(menuBox);
    end;

(****    Menu handling    ****)

procedure handleMousePress (event: EventRecord);
    var
        part: Integer;
        clickWindow: WindowPtr;
        savePort: GrafPtr;
    begin
    part := FindWindow(event.where, clickWindow);
    if part = inSysWindow then
        SystemClick(event, clickWindow)
    else if part = inMenuBar then
        mouseInMenu(event)
    end;

procedure mouseInMenu (event: EventRecord);
    var
        choice: LongInt;
        menuID, itemID: Integer;
    var
        itemText: Str255;
        err: OSErr;
    begin
    choice := MenuSelect(event.where);
    menuID := HiWord(choice);
    itemID := LoWord(choice);
    if menuID > 0 then
        begin
        if menuID = kAppleMenu then
            begin
            GetItem(GetMenu(kAppleMenu), itemID, itemText);
            err := OpenDeskAcc(itemText);
            end
        else if menuID = kFileMenu then
            begin
            if itemID = cQuit then
                ExitApp;
            end;
        end;
    HiliteMenu(0);
    end;

(****    Window handling    ****)

procedure handleWindowUpdate (event: EventRecord);
    var
        box: Rect;
    begin
    if event.message = LongInt(myWindow) then
        begin
        box := myWindow^.portRect;
        InsetRect(box, 16, 16);
        TextBox(myText^, GetHandleSize(myText), box, TEJustLeft);
        ValidRect(myWindow^.portRect);
        end;
    end;

(****    Top level event handling    ****)

procedure handleSuspend (event: EventRecord);
    begin
    slideMenuOff;
    end;

procedure handleResume (event: EventRecord);
    begin
    end;

procedure decodeOSEvent (event: EventRecord);
    var
        kind, flag: LongInt;
    begin
    kind := BitAnd(BitShift(event.message, -24), $0FF);
    flag := BitAnd(event.message, $01);
    if kind = suspendResumeMessage then
        begin
        if flag = 0 then
            begin
            event.what := suspendEvent;
            handleSuspend(event);
            end
        else if flag = 1 then
            begin
            event.what := resumeEvent;
            handleResume(event);
            end;
        end;
    end;

procedure handleNextEvent;
    var
        event: EventRecord;
        savePort: GrafPtr;
        w: WindowPtr;
    begin
    if WaitNextEvent(everyEvent, event, 0, nil) then
        begin
        if event.what = mouseDown then
            handleMousePress(event)
        else if event.what = updateEvt then
            begin
            GetPort(savePort);
            w := WindowPtr(event.message);
            SetPort(w);
            BeginUpdate(w);
            handleWindowUpdate(event);
            EndUpdate(w);
            SetPort(savePort);
            end
        else if event.what = osEvt then
            decodeOSEvent(event);
        end;
    end;

(****    Toolbox ritual incantations for starting and finishing    ****)

procedure initToolbox;
    var
        event: EventRecord;
    begin
    InitGraf(@thePort);
    InitFonts;
    InitWindows;
    InitMenus;
    TEInit;
    InitDialogs(nil);
    SetEventMask(everyEvent);
    FlushEvents(everyEvent, 0);
    InitCursor;
    end;

procedure exitApp;
    begin
    ExitToShell;
    end;

procedure openWindow;
    var
        bounds: Rect;
    begin
{ Give ourself a window }
    bounds.left := (screenBits.bounds.right - screenBits.bounds.left - 480) div 2;
    bounds.right := bounds.left + 480;
    bounds.top := 64;
    bounds.bottom := bounds.top + 240;
    myWindow := NewWindow(nil, bounds, 'Menu Slide', true, PlainDBox, WindowPtr(-1), False, 0);
    SetPort(myWindow);
{ Dig text for display out of resource fork }
    myText := GetResource('TEXT', 128);
    HLock(myText);
    end;

procedure createMenus;
    var
        m: MenuHandle;
    begin
    m := GetMenu(kAppleMenu);
    AddResMenu(m, 'DRVR');
    InsertMenu(m, 0);
    InsertMenu(GetMenu(kFileMenu), 0);
    InsertMenu(GetMenu(kEditMenu), 0);
    InsertMenu(GetMenu(kOtherMenu), 0);
    DrawMenuBar;
    end;

begin
initToolbox;
openWindow;
createMenus;
while true do
    handleNextEvent;
exitApp;
end.